;;; ROUTE.LST
;;; Copyright (c) 2001 Denis G. Zhonin
;;; All rights reserved
;;; This software is part of LASERCUT project
;;;
(defun C:ROUTE (/	     *error*	  acad-document
		osmode	     autosnap	  msg	       last-point
		sset_1	     ent_1	  grread-result
		ext-point    ext-length	  far-pt       near-pt
		start-pt     end-pt	  offs-pt-1    offs-pt-2
		line-vect    real-offs-pt
	       )
  ;; Define ERROR handler
  (defun *error* (msg)
    (setvar 'OSMODE osmode)
    (setvar 'AUTOSNAP autosnap)
    (princ (strcat "\n" msg "\n"))
  )
  ;; Load ActiveX extensions
  (vl-load-com)
  (load "fit-circle")
  ;; Save system variables
  (setq osmode (getvar "OSMODE"))
  (setq autosnap (getvar "AUTOSNAP"))
  ;; Start UNDO mark
  (vla-startundomark
    (setq acad-document (vla-get-activedocument (vlax-get-acad-object)))
  )
  ;; Set system variables
  (setvar 'OSMODE 1)
  (if (>= autosnap 16)
    (setvar 'AUTOSNAP (- autosnap 16))
  )
  ;; Function CASS
  ;; Extract 3D point from /num/ DXF group of /ent/ entity
  (defun cass (num ent)
    (cdr (assoc num ent))
  )
  ;; Function FAR
  ;; Return FAR point of /ent/ to /pt/
  (defun far (ent pt)
    (if	(> (distance (cass 10 ent) pt) (distance (cass 11 ent) pt))
      (cass 10 ent)
      (cass 11 ent)
    )
  )
  ;; Function NEAR
  ;; Return NEAR point of /ent/ to /pt/
  (defun near (ent pt)
    (if	(> (distance (cass 10 ent) pt) (distance (cass 11 ent) pt))
      (cass 11 ent)
      (cass 10 ent)
    )
  )
  ;; Function PATH-LINE
  ;; Draw line in layer /PATH/ from /start/ to /end/
  (defun path-line (start end)
    (if	(not (null start))
      (entmake
	(list
	  (cons '0 "LINE")
	  (cons '62 256)
	  (cons '8 "PATH")
	  (cons '10 start)
	  (cons '11 end)
	)
      )
    )
  )
  ;; Create layer "PATH"
  (entmake
    '((0 . "LAYER")
      (100 . "AcDbSymbolTableRecord")
      (100 . "AcDbLayerTableRecord")
      (2 . "PATH")
      (70 . 0)
      (62 . 4)				; Cyan
      (290 . 0)
     )
  )
  ;; Initialize "last-point" variable
  (setq last-point nil)
  ;; Initialize "sset_1" variable
  (setq sset_1 (ssadd))
  ;; MAIN loop
  (while t
    ;; Select line or circle
    (while (/= (sslength sset_1) 1)
      (setq sset_1 (ssget ":S"
			  '(		; only line or circle allowed
			    (-4 . "<OR")
			    (0 . "LINE")
			    (0 . "ARC")
			    (0 . "CIRCLE")
			    (-4 . "OR>")
			   )
		   )
      )
      ;; Loop if more or less then one entities in selection set
      (if (null sset_1)
	(setq sset_1 (ssadd))
      )
      (if (/= (sslength sset_1) 1)
	(princ
	  "\n>>> ROUTE: Too many (or less) entities selected!\n"
	)
      )
    )
    ;; Initialize "ent_1" variable
    (setq ent_1 (entget (ssname sset_1 0)))
    ;; Step 7
    (cond
      (
       (= (cass 0 ent_1) "LINE")
       ;; If line
       (progn
	 (initget 1 "Extend Offset")
	 (setq
	   l_opt (getpoint
		   "Specify profile's start point [Extend/Offset]: "
		 )
	 )
	 (terpri)
	 (cond
	   (
	    (equal "Extend" l_opt)
	    ;; Extend line
	    (progn
	      ;; Get point on drawing to calculate
	      ;; vector to stretch
	      (setq grread-result nil)
	      (princ "Select side to extend: ")
	      (while (/= 3 (car grread-result))
		(setq grread-result (grread nil 4 2))
	      )
	      (terpri)
	      (setq ext-point (cadr grread-result))
	      ;; Get value of stretch length
	      (initget 2)
	      (setq ext-length
		     (getint "Specify stretch length <4.0000>: ")
	      )
	      (if (null ext-length)
		(setq ext-length 4.)
	      )
	      (terpri)
	      (setq near-pt (near ent_1 ext-point))
	      (setq far-pt (far ent_1 ext-point))
	      ;; Modify entity ent_1
	      (setq ent_1
			  (subst
			    (cons
			      '10
			      (polar far-pt
				     (angle far-pt near-pt)
				     (+ (distance far-pt near-pt) ext-length)
			      )
			    )
			    (assoc 10 ent_1)
			    ent_1
			  )
		    ent_1 (subst (cons '11 far-pt) (assoc 11 ent_1) ent_1)
	      )
	      (entmod ent_1)
	      (path-line last-point (cass 10 ent_1))
	      (setq last-point
		     (getpoint "Specify profile's end point: ")
	      )
	      (terpri)
	    )
	   )
	   (
	    (equal "Offset" l_opt)
	    ;; Offset line
	    (progn
	      ;; Get point for drawing to it
	      (setq
		start-pt (getpoint "Specify point for drawing to: ")
	      )
	      (terpri)
	      (if (equal start-pt (cass 10 ent_1) 1e-5)
		(setq end-pt (cass 11 ent_1))
		(setq end-pt (cass 10 ent_1))
	      )
	      ;; Get point on drawing to calculate
	      ;; offset side
	      (setq grread-result nil)
	      (princ "Select side to drawing from: ")
	      (while (/= 3 (car grread-result))
		(setq grread-result (grread nil 4 2))
	      )
	      (terpri)
	      (setq ext-point (cadr grread-result))
	      ;; Get value of sub-line length
	      (initget 2)
	      (setq ext-length
		     (getint "Specify sub-line length <4.0000>: ")
	      )
	      (if (null ext-length)
		(setq ext-length 4.)
	      )
	      (terpri)
	      ;; Calculate vector of line
	      (setq line-vect (list
				(- (car end-pt) (car start-pt))
				(- (cadr end-pt) (cadr start-pt))
				(- (caddr end-pt) (caddr start-pt))
			      )
	      )
	      ;; Calculate first offset point
	      (setq
		offs-pt-1 (list
			    (+ (car start-pt) (- (cadr line-vect)))
			    (+ (cadr start-pt) (car line-vect))
			    (+ (caddr start-pt) (caddr line-vect))
			  )
	      )
	      ;; Calculate second offset point
	      (setq
		offs-pt-2 (list
			    (+ (car start-pt) (cadr line-vect))
			    (+ (cadr start-pt) (- (car line-vect)))
			    (+ (caddr start-pt) (caddr line-vect))
			  )
	      )
	      ;; Check intersection between line (offs-pt-1,ext-point)
	      ;; and infinite lenghten line (start-pt,end-pt)
	      (if (inters
		    offs-pt-1
		    ext-point
		    (polar start-pt (angle start-pt end-pt) 1000000.)
		    (polar end-pt (angle end-pt start-pt) 1000000.)
		  )
		;; if intersected
		(setq real-offs-pt
		       (polar start-pt
			      (angle start-pt offs-pt-2)
			      ext-length
		       )
		)
		;; if not intersected
		(setq real-offs-pt
		       (polar start-pt
			      (angle start-pt offs-pt-1)
			      ext-length
		       )
		)
	      )
	      ;; Draw sub-line
	      (entmake
		(list
		  (cons '0 "LINE")
		  (cons '62 3)
		  (cons '10 real-offs-pt)
		  (cons '11 start-pt)
		)
	      )
	      (path-line last-point real-offs-pt)
	      (setq last-point start-pt)
	    )
	   )
	   (t
	    ;; Point selected
	    (progn
	      (if (equal (cass 10 ent_1) l_opt 1e-5)
		;; If start of line selected
		(progn
		  (path-line last-point (cass 10 ent_1))
		)
		;; else
		(progn
		  (path-line last-point (cass 11 ent_1))
		)
	      )
	      (setq last-point
		     (getpoint "Specify profile's end point: ")
	      )
	      (terpri)
	    )
	   )
	 )
       )
      )
      (
       (= (cass 0 ent_1) "CIRCLE")
       ;; If circle
       (progn
	 (setq c_end (list (+ (car (cass 10 ent_1)) (cass 40 ent_1))
			   (cadr (cass 10 ent_1))
			   (caddr (cass 10 ent_1))
		     )
	 )
	 (setq c_start (list
			 (if (circle-has-child (ssname sset_1 0))
			   (+ (car c_end) 5)
			   (if (> (cass 40 ent_1) 5)
			     (- (car c_end) 5)
			     (car (cass 10 ent_1))
			   )
			 )

			 (cadr c_end)
			 (caddr c_end)
		       )
	 )
	 (entmake (list
		    (cons '0 "LINE")
		    (cons '62 3)
		    (cons '10 c_start)
		    (cons '11 c_end)
		  )
	 )
;;;	 (command "_arc" c_start "_en" c_end "_a" "180")
	 (path-line last-point c_start)
	 (setq last-point c_end)
       )
      )
      (
       (= (cass 0 ent_1) "ARC")
       (progn
	 (princ "\n>>>ROUTE: not implemented\n")
       )
      )
      ;; Not line, not circle, but what is it?
      (t (princ "\n>>> ROUTE: assertion failed on LINE 312\n"))
    )
    (setq sset_1 (ssadd))
  )					; MAIN loop
  ;; End UNDO mark
  (vla-endundomark acad-document)
  ;; Restore system variables
  (setvar 'OSMODE osmode)
  (setvar 'AUTOSNAP autosnap)
  ;; Exiting quietly
  (princ)
)
(princ "\nLASERCUT Router loaded\n")
(princ)
